perm filename LAP[LSP,SYS] blob
sn#000294 filedate 1973-07-03 generic text, type T, neo UTF8
(SETQ IBASE (SETQ BASE (ADD1 7)))
(DEFPROP LAP
(LAMBDA (SL)
(PROG (LOC CONLIST GEN REMOB L)
(SETQ GEN (GENSYM))
(SETQ CONLIST (LIST NIL))
(SETQ LOC BPORG)
A (COND ((NULL (SETQ L (READ))) (GO END))
((ATOM L) (DEFLOC L LOC) (GO A)))
(DEPOSIT LOC (GWD L))
(SETQ LOC (ADD1 LOC))
(GO A)
END (DEFLOC GEN LOC)
EN1 (COND ((NULL (SETQ CONLIST (CDR CONLIST)))
(EVAL (CONS (QUOTE REMOB) REMOB))
(PUTPROP (CAR SL) (NUMVAL BPORG) (CADR SL))
(RETURN (LIST (CAR SL) (SETQ BPORG LOC)))))
(SETQ KLIST (CONS (CONS (CAR CONLIST) LOC) KLIST))
(DEPOSIT LOC (GWD (CAR CONLIST)))
(SETQ LOC (ADD1 LOC))
(GO EN1)))
FEXPR)
(DEFPROP TYPE (LAMBDA (X) (COND ((NUMBERP X) (CADR X)))) EXPR)
(DEFPROP GWD
(LAMBDA (X)
(PROG (WRD FLD)
(SETQ FLD (QUOTE ((22 . -1) (27 . 17) (0 . 777777) (22 . 777777))))
(SETQ WRD 0)
(MAPCAR
(FUNCTION (LAMBDA (ZZ)
(PROG2 (SETQ WRD
(PLUS WRD
(LSH (BOOLE 1
(CDAR FLD)
(LAPEVAL ZZ))
(CAAR FLD))))
(SETQ FLD (CDR FLD)))))
X)
(RETURN WRD)))
EXPR)
(DEFPROP LAPEVAL
(LAMBDA (X)
(COND ((NUMBERP X) X)
((ATOM X) (GVAL X))
((MEMBER (CAR X) (QUOTE (E QUOTE)))
(MAKNUM (COND ((OR (NOT (ATOM (SETQ X (CADR X))))
(AND (NUMBERP X) (NOT (EQ (PLUS X 0) X)))
(EQ (CAR (EXPLODE X)) (QUOTE /")))
(PROG (Y)
(SETQ Y QLIST)
A (COND ((NULL Y)
(RETURN (CAR (SETQ QLIST
(CONS X QLIST)))))
((AND (EQUAL X (CAR Y))
(EQ (TYPE X) (TYPE (CAR Y))))
(RETURN (CAR Y))))
(SETQ Y (CDR Y))
(GO A)))
(T X))
(QUOTE FIXNUM)))
((EQ (CAR X) (QUOTE SPECIAL))
(COND ((NULL (GET (CADR X) (QUOTE VALUE)))
(PUTPROP (CADR X) (LIST NIL) (QUOTE VALUE))))
(MAKNUM (GET (CADR X) (QUOTE VALUE)) (QUOTE FIXNUM)))
((EQ (CAR X) (QUOTE C))
(PROG (N CPTR)
(SETQ CPTR KLIST)
L11 (COND ((NULL CPTR) (GO L12))
((EQUAL (CDR X) (CAAR CPTR)) (RETURN (CDAR CPTR))))
(SETQ CPTR (CDR CPTR))
(GO L11)
L12 (GVAL GEN)
(SETQ N 0)
(SETQ CPTR CONLIST)
A (COND ((NULL (CDR CPTR)) (RPLACD CPTR (LIST (CDR X)))))
(COND ((EQUAL (CDR X) (CADR CPTR)) (RETURN N)))
(SETQ N (ADD1 N))
(SETQ CPTR (CDR CPTR))
(GO A)))
(T (PLUS (LAPEVAL (CAR X)) (LAPEVAL (CDR X))))))
EXPR)
(DEFPROP DEFLOC
(LAMBDA (SYM VAL)
(PROG (Z)
(SETQ REMOB (CONS SYM REMOB))
(COND ((SETQ Z (GET SYM (QUOTE UNDEF))) (GO PATCH)))
A (RETURN (PUTPROP SYM VAL (QUOTE SYM)))
PATCH(COND ((NULL Z) (RPLACD SYM (CDDDR SYM)) (GO A)))
(DEPOSIT (CAR Z) (PLUS (EXAMINE (CAR Z)) VAL))
(SETQ Z (CDR Z))
(GO PATCH)))
EXPR)
(DEFPROP DEFSYM (LAMBDA (SYM VAL) (PUTPROP SYM VAL (QUOTE SYM))) EXPR)
(DEFPROP GVAL
(LAMBDA (SYM)
(COND ((GET SYM (QUOTE SYM)))
((GET SYM (QUOTE VALUE)) (MAKNUM SYM (QUOTE FIXNUM)))
(T (PUTPROP SYM
(CONS LOC (GET SYM (QUOTE UNDEF)))
(QUOTE UNDEF))
0)))
EXPR)
(DEFPROP OPS
(LAMBDA (L)
(PROG NIL
A (COND ((NULL L) (RETURN T)))
(DEFSYM (CAAR L) (CADAR L))
(SETQ L (CDR L))
(GO A)))
FEXPR)
(DEFPROP REMLAP
(LAMBDA NIL
(PROG (Z)
(SETQ Z
(QUOTE (LAP LAPEVAL
GWD
DEFLOC
DEFSYM
REMLAP
ILAP
GVAL
TYPE)))
A (COND ((NULL Z) (GO B)))
(REMPROP (CAR Z) (QUOTE EXPR))
(REMPROP (CAR Z) (QUOTE FEXPR))
(SETQ Z (CDR Z))
(GO A)
B (REMPROP (QUOTE REMLAP) (QUOTE EXPR))))
EXPR)
(OPS
(ADD 270000)
(CALL 34000)
(CALLF 36000)
(CALLF@ 36020)
(CAIE 302000)
(CAIN 306000)
(CAME 312000)
(CAMN 316000)
(CLEARB 403000)
(CLEARM 402000)
(DPB 137000)
(EXCH 250000)
(HLLZS@ 513020)
(HLRZ 554000)
(HLRZ@ 554020)
(HRLM 506000)
(HRLM@ 506020)
(HRRM 542000)
(HRRZS@ 553020)
(HRRZ 550000)
(HRRM@ 542020)
(HRRZ@ 550020)
(JCALL 35000)
(JCALLF 37000)
(JCALLF@ 37020)
(JRST 254000)
(JSP 265000)
(JUMPE 322000)
(JUMPN 326000)
(MOVE 200000)
(MOVEI 201000)
(MOVEM 202000)
(MOVNI 211000)
(P 14)
(POP 262000)
(POPJ 263000)
(PUSH 261000)
(PUSHJ 260000)
(SOJE 362000)
(SOJN 366000)
(SUB 274000)
(TDZA 634000))
(COND ((NULL (GET (QUOTE QLIST) (QUOTE VALUE))) (SETQ QLIST NIL)))
(COND ((NULL (GET (QUOTE KLIST) (QUOTE VALUE))) (SETQ KLIST NIL)))
(SETQ SAVEBPORG BPORG)
(SETQ LAPORG BPEND)
(SETQ SAVELAPORG (SETQ BPORG (*DIF BPEND 500)))
(LAP GWD SUBR)
(PUSH P (C 0))
(PUSH P 1)
(PUSHJ P G0123)
(137000 1 (C 222200 0 -1 P))
(PUSHJ P G0123)
(242000 1 27)
(436000 1 -1 P)
(PUSHJ P G0123)
(137000 1 (C 2200 0 -1 P))
(PUSHJ P G0123)
(514000 1 1)
(436000 1 -1 P)
G0124 (POP P 1)
(POP P 1)
(JRST 0 FIX1A)
G0125 (POP P 1)
(JRST 0 G0124)
G0123 (MOVE 2 -1 P)
(JUMPE 2 G0125)
(HLRZ 1 0 2)
(HRRZ 2 0 2)
(MOVEM 2 -1 P)
(CALL 1 (E LAPEVAL))
(JRST 0 NUMVAL)
NIL
(LAP LAP FSUBR)
(JSP 6 SPECBIND)
(0 0 (SPECIAL LOC))
(0 0 (SPECIAL CONLIST))
(0 0 (SPECIAL GEN))
(0 0 (SPECIAL REMOB))
(PUSH P 1)
(CALL 0 (E GENSYM))
(MOVEM 1 (SPECIAL GEN))
(MOVEI 1 (QUOTE NIL))
(CALL 1 (E NCONS))
(MOVEM 1 (SPECIAL CONLIST))
(MOVE 2 (SPECIAL BPORG))
(MOVEM 2 (SPECIAL LOC))
(PUSH P (C 0 0 (QUOTE NIL)))
G0001 (CALL 0 (E READ))
(MOVEM 1 0 P)
(JUMPE 1 G0002)
(CALL 1 (E ATOM))
(JUMPE 1 G0011)
(MOVE 2 (SPECIAL LOC))
(MOVE 1 0 P)
(CALL 2 (E DEFLOC))
(JRST 0 G0001)
G0011 (MOVE 1 0 P)
(PUSH P (SPECIAL LOC))
(CALL 1 (E GWD))
(MOVE 2 1)
(POP P 1)
(CALL 2 (E DEPOSIT))
(MOVE 1 (SPECIAL LOC))
(CALL 1 (E ADD1))
(MOVEM 1 (SPECIAL LOC))
(MOVE 2 (SPECIAL LAPORG))
(CALL 2 (E *LESS))
(JUMPN 1 G0001)
(MOVEI 1 (QUOTE (BINARY PROGRAM SPACE EXCEEDED)))
(CALL 1 (E PRINT))
(CALL 0 (E ERR))
(JRST 0 G0001)
G0002 (MOVE 2 (SPECIAL LOC))
(MOVE 1 (SPECIAL GEN))
(CALL 2 (E DEFLOC))
G0003 (HRRZ@ 1 (SPECIAL CONLIST))
(MOVEM 1 (SPECIAL CONLIST))
(JUMPN 1 G0022)
(MOVE 1 (SPECIAL REMOB))
(CALL 17 (E REMOB))
(HLRZ@ 1 -1 P)
(PUSH P 1)
(MOVE 1 (SPECIAL BPORG))
(CALL 1 (E NUMVAL))
(HRRZ@ 3 -2 P)
(HLRZ@ 3 3)
(MOVE 2 1)
(POP P 1)
(CALL 3 (E PUTPROP))
(MOVE 1 (SPECIAL LOC))
(MOVEM 1 (SPECIAL BPORG))
(CALL 1 (E NCONS))
(HLRZ@ 2 -1 P)
(CALL 2 (E XCONS))
(JRST 0 G0004)
G0022 (MOVE 2 (SPECIAL LOC))
(HLRZ@ 1 (SPECIAL CONLIST))
(CALL 2 (E CONS))
(MOVE 2 (SPECIAL KLIST))
(CALL 2 (E CONS))
(MOVEM 1 (SPECIAL KLIST))
(HLRZ@ 1 (SPECIAL CONLIST))
(PUSH P (SPECIAL LOC))
(CALL 1 (E GWD))
(MOVE 2 1)
(POP P 1)
(CALL 2 (E DEPOSIT))
(MOVE 1 (SPECIAL LOC))
(CALL 1 (E ADD1))
(MOVEM 1 (SPECIAL LOC))
(JRST 0 G0003)
G0004 (SUB P (C 0 0 2 2))
(JRST 0 SPECSTR)
NIL
(LAP LAPEVAL SUBR)
(PUSH P 1)
(CALL 1 (E NUMBERP))
(JUMPE 1 G0006)
(MOVE 1 0 P)
(JRST 0 G0005)
G0006 (MOVE 1 0 P)
(CALL 1 (E ATOM))
(JUMPE 1 G0008)
(MOVE 1 0 P)
(CALL 1 (E GVAL))
(JRST 0 G0005)
G0008 (MOVEI 2 (QUOTE (E QUOTE)))
(HLRZ@ 1 0 P)
(CALL 2 (E MEMBER))
(JUMPE 1 G0011)
(HRRZ@ 1 0 P)
(HLRZ@ 1 1)
(MOVEM 1 0 P)
(CALL 1 (E ATOM))
(JUMPE 1 G0016)
(MOVE 1 0 P)
(CALL 1 (E NUMBERP))
(JUMPE 1 G0019)
(MOVEI 2 (QUOTE 0))
(MOVE 1 0 P)
(CALL 2 (E *PLUS))
(CAME 1 0 P)
(JRST 0 G0016)
G0019 (MOVE 1 0 P)
(CALL 1 (E EXPLODE))
(HLRZ@ 2 1)
(CAIE 2 (QUOTE /"))
(JRST 0 G0015)
G0016 (PUSH P (SPECIAL QLIST))
G0001 (MOVE 1 0 P)
(JUMPN 1 G0028)
(MOVE 2 (SPECIAL QLIST))
(MOVE 1 -1 P)
(CALL 2 (E CONS))
(MOVEM 1 (SPECIAL QLIST))
(HLRZ@ 1 1)
(JRST 0 G0024)
G0028 (HLRZ@ 2 1)
(MOVE 1 -1 P)
(CALL 2 (E EQUAL))
(JUMPE 1 G0032)
(MOVE 1 -1 P)
(CALL 1 (E TYPE))
(PUSH P 1)
(HLRZ@ 1 -1 P)
(CALL 1 (E TYPE))
(POP P 2)
(CAME 1 2)
(JRST 0 G0032)
(HLRZ@ 1 0 P)
(JRST 0 G0024)
G0032 (HRRZ@ 1 0 P)
(MOVEM 1 0 P)
(JRST 0 G0001)
G0024 (SUB P (C 0 0 1 1))
(JRST 0 G0014)
G0015 (MOVE 1 0 P)
G0045
G0014 (MOVEI 2 (QUOTE FIXNUM))
(CALL 2 (E MAKNUM))
(JRST 0 G0005)
G0011 (HLRZ@ 1 0 P)
(CAIE 1 (QUOTE SPECIAL))
(JRST 0 G0049)
(MOVEI 2 (QUOTE VALUE))
(HRRZ@ 1 0 P)
(HLRZ@ 1 1)
(CALL 2 (E GET))
(JUMPN 1 G0052)
(CALL 1 (E NCONS))
(MOVEI 3 (QUOTE VALUE))
(MOVE 2 1)
(HRRZ@ 1 0 P)
(HLRZ@ 1 1)
(CALL 3 (E PUTPROP))
G0052 (MOVEI 2 (QUOTE VALUE))
(HRRZ@ 1 0 P)
(HLRZ@ 1 1)
(CALL 2 (E GET))
(MOVEI 2 (QUOTE FIXNUM))
(CALL 2 (E MAKNUM))
(JRST 0 G0005)
G0049 (CAIE 1 (QUOTE C))
(JRST 0 G0062)
(PUSH P (SPECIAL KLIST))
(PUSH P (C 0 0 (QUOTE NIL)))
G0002 (MOVE 1 -1 P)
(JUMPE 1 G0003)
(HLRZ@ 2 1)
(HLRZ@ 2 2)
(HRRZ@ 1 -2 P)
(CALL 2 (E EQUAL))
(JUMPE 1 G0068)
(HLRZ@ 1 -1 P)
(HRRZ@ 1 1)
(JRST 0 G0064)
G0068 (HRRZ@ 1 -1 P)
(MOVEM 1 -1 P)
(JRST 0 G0002)
G0003 (MOVE 1 (SPECIAL GEN))
(CALL 1 (E GVAL))
(MOVEI 2 (QUOTE 0))
(MOVE 3 (SPECIAL CONLIST))
(MOVEM 3 -1 P)
(MOVEM 2 0 P)
G0004 (HRRZ@ 1 -1 P)
(JUMPN 1 G0079)
(HRRZ@ 1 -2 P)
(CALL 1 (E NCONS))
(HRRM@ 1 -1 P)
G0079 (HRRZ@ 2 -1 P)
(HLRZ@ 2 2)
(HRRZ@ 1 -2 P)
(CALL 2 (E EQUAL))
(JUMPE 1 G0085)
(MOVE 1 0 P)
(JRST 0 G0064)
G0085 (MOVE 1 0 P)
(CALL 1 (E ADD1))
(MOVEM 1 0 P)
(HRRZ@ 1 -1 P)
(MOVEM 1 -1 P)
(JRST 0 G0004)
G0064 (SUB P (C 0 0 2 2))
(JRST 0 G0005)
G0062 (HLRZ@ 1 0 P)
(CALL 1 (E LAPEVAL))
(PUSH P 1)
(HRRZ@ 1 -1 P)
(CALL 1 (E LAPEVAL))
(POP P 2)
(CALL 2 (E *PLUS))
G0095
G0005 (SUB P (C 0 0 1 1))
(POPJ P)
NIL
(LAP DEFLOC SUBR)
(PUSH P 2)
(MOVE 2 (SPECIAL REMOB))
(PUSH P 1)
(CALL 2 (E CONS))
(MOVEM 1 (SPECIAL REMOB))
(PUSH P (C 0 0 (QUOTE NIL)))
(MOVEI 2 (QUOTE UNDEF))
(MOVE 1 -1 P)
(CALL 2 (E GET))
(MOVEM 1 0 P)
(JUMPN 1 G0002)
G0001 (MOVEI 3 (QUOTE SYM))
(MOVE 2 -2 P)
(MOVE 1 -1 P)
(CALL 3 (E PUTPROP))
(JRST 0 G0003)
G0002 (MOVE 1 0 P)
(JUMPN 1 G0013)
(HRRZ@ 2 -1 P)
(HRRZ@ 2 2)
(HRRZ@ 2 2)
(HRRM@ 2 -1 P)
(JRST 0 G0001)
G0013 (HLRZ@ 1 0 P)
(PUSH P 1)
(CALL 1 (E EXAMINE))
(MOVE 2 -3 P)
(CALL 2 (E *PLUS))
(MOVE 2 1)
(POP P 1)
(CALL 2 (E DEPOSIT))
(HRRZ@ 1 0 P)
(MOVEM 1 0 P)
(JRST 0 G0002)
G0003 (SUB P (C 0 0 3 3))
(POPJ P)
NIL
(LAP DEFSYM SUBR)
(MOVEI 3 (QUOTE SYM))
(JCALL 3 (E PUTPROP))
NIL
(LAP GVAL SUBR)
(PUSH P 1)
(MOVEI 2 (QUOTE SYM))
(CALL 2 (E GET))
(JUMPN 1 G0001)
(MOVEI 2 (QUOTE VALUE))
(MOVE 1 0 P)
(CALL 2 (E GET))
(JUMPE 1 G0003)
(MOVEI 2 (QUOTE FIXNUM))
(MOVE 1 0 P)
(CALL 2 (E MAKNUM))
(JRST 0 G0001)
G0003 (MOVEI 2 (QUOTE UNDEF))
(MOVE 1 0 P)
(CALL 2 (E GET))
(MOVE 2 (SPECIAL LOC))
(CALL 2 (E XCONS))
(MOVEI 3 (QUOTE UNDEF))
(MOVE 2 1)
(MOVE 1 0 P)
(CALL 3 (E PUTPROP))
(MOVEI 1 (QUOTE 0))
G0006
G0001 (SUB P (C 0 0 1 1))
(POPJ P)
NIL
(LAP TYPE SUBR)
(PUSH P 1)
(CALL 1 (E NUMBERP))
(JUMPE 1 G0002)
(HRRZ@ 1 0 P)
(HLRZ@ 1 1)
G0002 (SUB P (C 0 0 1 1))
(POPJ P)
NIL
(SETQ KLIST NIL)
(SETQ LAPORG SAVELAPORG)
(SETQ BPORG SAVEBPORG)
(REMLAP)
(MAPC (FUNCTION (LAMBDA (X) (REMPROP X (QUOTE MACRO))))
(QUOTE (DEFSYM LAP OPS)))